第 12 章 交互图形

plotly 包的函数使用起来还是比较复杂的,特别是需要打磨细节以打造数据产品时,此外,其依赖相当重,仅数据处理就包含两套方法 — dplyr 和 data.table,引起很多函数冲突,可谓「苦其久矣」!因此,准备另起炉灶,开发一个新的 R 包 qplotly,取意 quick plotly,以 qplot_ly() 替代 plot_ly()。类似简化 API 的工作有 simplevisautoplotlyggfortifyplotme

plotly 团队开发了 plotly.js 库,且维护了 R 接口文档 (https://plotly.com/r/),Carson Sievert 开发了 plotly 包,配套书 Interactive web-based data visualization with R, plotly, and shiny。 Paul C. Bauer 的书 Applied Data Visualization 介绍 plotly https://bookdown.org/paul/applied-data-visualization/what-is-plotly.html

echarts4r 包基于 Apache ECharts (incubating),ECharts 的 Python 接口 pyecharts 也非常受欢迎,基于 apexcharts.jsapexcharterECharts2Shiny 包将 ECharts 嵌入 shiny 框架中。

timevis 创建交互式的时间线的时序可视化,它基于 Visvis-timeline 模块,支持 shiny 集成。dygraphs 包基于 dygraphs 可视化库,将时序数据可视化,更多情况见 https://dygraphs.com/leaflet 提供 leaflet 的 R 接口。rAmCharts4 基于 amCharts 4 库, apexcharter 提供 apexcharts.js 的 R 接口。还有 billboarder 等。更完整地,请看 Etienne Bacher 维护的 R 包列表 r-js-adaptation

对于想了解 htmlwidgets 框架,JavaScript 响应式编程的读者,推荐 John Coene 新书 JavaScript for R

学习 plotlyhighcharter 为代表的 基于 JavaScript 的 R 包,共有四重境界:第一重是照着帮助文档的示例,示例有啥我们做啥;第二重是明白帮助文档中 R 函数和 JavaScript 函数的对应关系,能力达到 JS 库的功能边界;第三重是深度自定义一些扩展性的 JS 功能,放飞自我;第四重是重新造轮子,为所欲为。下面的介绍希望能帮助读者到达第二重境界。

plotly 是一个功能非常强大的绘制交互式图形的 R 包。它支持下载图片、添加水印、自定义背景图片、工具栏和注释45 等一系列细节的自定义控制。下面结合 JavaScript 库 plotly.js 一起介绍,帮助文档 ?config 没有太详细地介绍,所以我们看看 config() 函数中参数 ... 和 JavaScript 库 plot_config.js 中的功能函数是怎么对应的。图12.1 中图片下载按钮对应 toImageButtonOptions 参数, 看 toImageButtonOptions 源代码,可知,它接受任意数据类型,对应到 R 里面就是列表。 watermarkdisplaylogo 都是传递布尔值(TRUE/FALSE),具体根据 JavaScript 代码中的 valType (参数值类型)决定,其它参数类似。另一个函数 layout 和函数 config() 是类似的,怎么传递参数值是根据 JavaScript 代码来的。

toImageButtonOptions: {
    valType: 'any',
    dflt: {},
    description: [
        'Statically override options for toImage modebar button',
        'allowed keys are format, filename, width, height, scale',
        'see ../components/modebar/buttons.js'
    ].join(' ')
},
displaylogo: {
    valType: 'boolean',
    dflt: true,
    description: [
        'Determines whether or not the plotly logo is displayed',
        'on the end of the mode bar.'
    ].join(' ')
},
watermark: {
    valType: 'boolean',
    dflt: false,
    description: 'watermark the images with the company\'s logo'
},
library(plotly, warn.conflicts = FALSE)
plot_ly(diamonds,
  x = ~clarity, y = ~price,
  color = ~clarity, colors = "Set1", type = "box"
) %>%
  config(
    toImageButtonOptions = list(
      format = "svg", width = 450, height = 300,
      filename = paste("plot", Sys.Date(), sep = "_")
    ), 
    modeBarButtons = list(list("toImage")),
    watermark = FALSE,
    displaylogo = FALSE, 
    locale = "zh-CN", 
    staticPlot = TRUE,
    showLink = FALSE,
    modeBarButtonsToRemove = c(
      "hoverClosestCartesian", "hoverCompareCartesian", 
      "zoom2d", "zoomIn2d", "zoomOut2d", 
      "autoScale2d", "resetScale2d", "pan2d",
      "toggleSpikelines"
    )
  ) %>%
  layout(
    template = "plotly_dark",
    images = list(
      source = "https://images.plot.ly/language-icons/api-home/r-logo.png",
      xref = "paper",
      yref = "paper",
      x = 1.00,
      y = 0.25,
      sizex = 0.2,
      sizey = 0.2,
      opacity = 0.5
    ),
    annotations = list(
      text = "DRAFT",               # 水印文本
      textangle = -30,              # 逆时针旋转 30 度
      font = list(
        size = 40,                  # 字号
        color = "gray",             # 颜色
        family = "Times New Roman"  # 字族
      ),
      opacity = 0.2,                # 透明度
      xref = "paper",
      yref = "paper",
      x = 0.5,
      y = 0.5,
      showarrow = FALSE             # 去掉箭头指示
    )
  )

图 12.1: 自定义细节

表 12.1: 交互图形的设置函数 config() 各个参数及其作用(部分)
参数 作用
displayModeBar 是否显示交互图形上的工具条,默认显示 TRUE46
modeBarButtons 工具条上保留的工具,如下载 "toImage",缩放 "zoom2d"47
modeBarButtonsToRemove 工具条上要移除的工具,如下载和缩放图片 c("toImage", "zoom2d")
toImageButtonOptions 工具条上下载图片的选项设置,包括名称、类型、尺寸等。48
displaylogo 是否交显示互图形上 Plotly 的图标,默认显示 TRUE49
staticPlot 是否将交互图形转为静态图形,默认 FALSE
locale 本土化语言设置,比如 "zh-CN" 表示中文。

12.1 散点图

表 12.2: 散点图类型
类型 名称
scattercarpet 地毯图
scatterternary 三元图
scatter3d 三维散点图
scattergeo 地图散点图
scattermapbox 地图散点图 Mapbox
scatter 散点图
scattergl 散点图 GL
scatterpolar 极坐标散点图
scatterpolargl 极坐标散点图 GL

plotly.js 提供很多图层用于绘制各类图形 https://github.com/plotly/plotly.js/tree/master/src/traces

# 折线图
plot_ly(Orange,
  x = ~age, y = ~circumference, color = ~Tree,
  type = "scatter", mode = "markers"
)

图 12.2: 其它常见图形

12.2 条形图

日常使用最多的图形无外乎散点图、柱形图(分组、堆积、百分比堆积等)

# 简单条形图
library(data.table)
diamonds <- as.data.table(diamonds)

p11 <- diamonds[, .(cnt = .N), by = .(cut)] %>%
  plot_ly(x = ~cut, y = ~cnt, type = "bar") %>%
  add_text(
    text = ~ scales::comma(cnt), y = ~cnt,
    textposition = "top middle",
    cliponaxis = FALSE, showlegend = FALSE
  )
# 分组条形图
p12 <- plot_ly(diamonds,
  x = ~cut, color = ~clarity,
  colors = "Accent", type = "histogram"
) 
# 堆积条形图
p13 <- plot_ly(diamonds,
  x = ~cut, color = ~clarity,
  colors = "Accent", type = "histogram"
) %>%
  layout(barmode = "stack")
# 百分比堆积条形图
# p14 <- plot_ly(diamonds,
#   x = ~cut, color = ~clarity,
#   colors = "Accent", type = "histogram"
# ) %>%
#   layout(barmode = "stack", barnorm = "percent") %>%
#   config(displayModeBar = F)

# 推荐使用如下方式绘制堆积条形图
dat = diamonds[, .(cnt = length(carat)), by = .(clarity, cut)] %>%
  .[, pct := round(100 * cnt / sum(cnt), 2), by = .(cut)]

p14 <- plot_ly(
  data = dat, x = ~cut, y = ~pct, color = ~clarity,
  colors = "Set3", type = "bar"
) %>%
  layout(barmode = "stack")

htmltools::tagList(p11, p12, p13, p14)

12.3 折线图

其它常见的图形还要折线图、直方图、箱线图和提琴图

# 折线图
plot_ly(Orange,
  x = ~age, y = ~circumference, color = ~Tree,
  type = "scatter", mode = "markers+lines"
)

图 12.3: 折线图

12.4 双轴图

双轴图

模拟一组数据

set.seed(2020)
dat <- data.frame(
  dt = seq(from = as.Date("2020-01-01"), to = as.Date("2020-01-31"), by = "day"),
  search_qv = sample(100000:1000000, size = 31, replace = T)
) %>%
  transform(valid_click_qv = sapply(search_qv, rbinom, n = 1, prob = 0.5)) %>%
  transform(qv_ctr = valid_click_qv / search_qv)

hoverinfo = "text" 表示 tooltips 使用指定的 text 映射,而 visible = "legendonly" 表示图层默认隐藏不展示,只在图例里显示,有时候很多条线,默认只是展示几条而已。举例如下

plot_ly(data = dat) %>%
  add_bars(
    x = ~dt, y = ~search_qv, color = I("gray80"), name = "搜索 QV",
    text = ~ paste0(
      "日期:", dt, "<br>",
      "点击 QV:", format(valid_click_qv, big.mark = ","), "<br>",
      "搜索 QV:", format(search_qv, big.mark = ","), "<br>",
      "QV_CTR:", scales::percent(qv_ctr, accuracy = 0.01), "<br>"
    ),
    hoverinfo = "text"
  ) %>%
  add_bars(
    x = ~dt, y = ~valid_click_qv, color = I("gray60"), name = "点击 QV",
    text = ~ paste0(
      "日期:", dt, "<br>",
      "点击 QV:", format(valid_click_qv, big.mark = ","), "<br>",
      "搜索 QV:", format(search_qv, big.mark = ","), "<br>",
      "QV_CTR:", scales::percent(qv_ctr, accuracy = 0.01), "<br>"
    ), visible = "legendonly",
    hoverinfo = "text"
  ) %>%
  add_lines(
    x = ~dt, y = ~qv_ctr, name = "QV_CTR", yaxis = "y2", color = I("gray40"),
    text = ~ paste("QV_CTR:", scales::percent(qv_ctr, accuracy = 0.01), "<br>"), 
    hoverinfo = "text",
    line = list(shape = "spline", width = 3, dash = "line")
  ) %>%
  layout(
    title = "",
    yaxis2 = list(
      tickfont = list(color = "black"),
      overlaying = "y",
      side = "right",
      title = "QV_CTR(%)",
      # ticksuffix = "%", # 设置坐标轴单位
      tickformat = '.1%', # 设置坐标轴刻度
      showgrid = F, automargin = TRUE
    ),
    xaxis = list(title = "日期", showgrid = F, showline = F),
    yaxis = list(title = " ", showgrid = F, showline = F),
    margin = list(r = 20, autoexpand = T),
    legend = list(
      x = 0, y = 1, orientation = "h",
      title = list(text = " ")
    )
  )

图 12.4: 双轴图

12.5 直方图

plot_ly(iris,
  x = ~Sepal.Length, colors = "Greys",
  color = ~Species, type = "histogram"
)

图 12.5: 分组直方图

12.6 箱线图

# 箱线图
plot_ly(diamonds,
  x = ~clarity, y = ~price, colors = "Greys",
  color = ~clarity, type = "box"
)

图 12.6: 箱线图

12.7 提琴图

plot_ly(sleep,
  x = ~group, y = ~extra, split = ~group,
  type = "violin",
  box = list(visible = T),
  meanline = list(visible = T)
)

图 12.7: 提琴图

plotly 包含图层 27 种,见表 12.3

表 12.3: 图层
A B C
add_annotations add_histogram add_polygons
add_area add_histogram2d add_ribbons
add_bars add_histogram2dcontour add_scattergeo
add_boxplot add_image add_segments
add_choropleth add_lines add_sf
add_contour add_markers add_surface
add_data add_mesh add_table
add_fun add_paths add_text
add_heatmap add_pie add_trace

12.8 气泡图

简单图形 scatter,分布图几类,其中 scatter、heatmap、scatterpolar 支持 WebGL 绘图引擎

# https://plotly.com/r/bubble-charts/
dat <- diamonds[, .(
  carat = mean(carat),
  price = sum(price), 
  cnt = .N
), by = .(cut)]

plot_ly(
  data = dat, colors = "Greys",
  x = ~carat, y = ~price, color = ~cut, size = ~cnt,
  type = "scatter", mode = "markers",
  marker = list(
    symbol = "circle", sizemode = "diameter",
    line = list(width = 2, color = "#FFFFFF"), opacity = 0.4
  ),
  text = ~ paste(
    sep = " ", "重量:", round(carat, 2), "克拉",
    "<br>价格:", round(price / 10^6, 2), "百万"
  ),
  hoverinfo = 'text'
) %>%
  add_annotations(
    x = ~carat, y = ~price, text = ~cnt,
    showarrow = F, font = list(family = "sans")
  ) %>%
  layout(
    xaxis = list(hoverformat = ".2f"),
    yaxis = list(hoverformat = ".0f")
  )

图 12.8: 气泡图

12.9 曲线图

plot_ly(
  x = c(1, 2.2, 3), y = c(5.3, 6, 7), 
  type = "scatter", color = I("gray40"), 
  mode = "markers+lines", line = list(shape = "spline")
) %>%
  add_annotations(
    x = 2, y = 6, size = I(100),
    text = TeX("x_i \\sim N(\\mu, \\sigma)")
  ) %>% 
  layout(
    xaxis = list(showgrid = F, title = TeX("\\mu")),
    yaxis = list(showgrid = F, title = TeX("\\alpha"))
  ) %>% 
  config(mathjax = 'cdn')

图 12.9: 平滑曲线图

12.10 堆积图

plot_ly(
  data = PlantGrowth, y = ~weight,
  color = ~group, colors = "Greys",
  type = "scatter", line = list(shape = "spline"),
  mode = "lines", fill = "tozeroy"
)

12.11 热力图

其他基础图形

plot_ly(z = volcano, type = 'heatmap', colors = "Greys")

12.12 地图 I

plot_mapbox() 使用 Mapbox 提供的地图服务,因此,需要注册一个账户,获取 MAPBOX_TOKEN

data("quakes")
plot_mapbox(
  data = quakes, colors = "Greys",
  lon = ~long, lat = ~lat,
  color = ~mag, size = 2,
  type = "scattermapbox", 
  mode = "markers",
  marker = list(opacity = 0.5)
) %>%
  layout(
    title = "Fiji Earthquake",
    mapbox = list(
      zoom = 3,
      center = list(
        lat = ~ median(lat - 5),
        lon = ~ median(long)
      )
    )
  ) %>%
  config(
    mapboxAccessToken = Sys.getenv("MAPBOX_TOKEN")
  )

图 12.10: 斐济地震数据

plotly::plot_ly(
  data = quakes,
  lon = ~long, lat = ~lat,
  type = "scattergeo", mode = "markers",
  text = ~ paste0(
    "站点:", stations, "<br>",
    "震级:", mag
  ),
  marker = list(
    color = ~mag, 
    size = 10, opacity = 0.8,
    line = list(color = "white", width = 1)
  )
) %>%
  plotly::layout(geo = list(
    showland = TRUE,
    landcolor = plotly::toRGB("gray95"),
    subunitcolor = plotly::toRGB("gray85"),
    countrycolor = plotly::toRGB("gray85"),
    countrywidth = 0.5,
    subunitwidth = 0.5,
    lonaxis = list(
      showgrid = TRUE,
      gridwidth = 0.5,
      range = c(160, 190),
      dtick = 5
    ),
    lataxis = list(
      showgrid = TRUE,
      gridwidth = 0.5,
      range = c(-40, -10),
      dtick = 5
    )
  ))

图 12.11: 斐济地震带分布

dat <- data.frame(state.x77,
  stats = rownames(state.x77),
  stats_abbr = state.abb
)

plotly::plot_ly(
  data = dat,
  type = "choropleth",
  locations = ~stats_abbr,
  locationmode = "USA-states",
  colorscale = "Viridis",
  z = ~Income
) |>
  plotly::layout(
    geo = list(scope = "usa"),
    title = "1974年美国各州的人均收入",
    legend = list(title = "收入")
  ) |>
  plotly::config(displayModeBar = FALSE)

图 12.12: 美国各州收入

12.13 拟合图

plot_ly(economics,
  type = "scatter",
  x = ~date,
  y = ~uempmed,
  name = "observed unemployment",
  mode = "markers+lines",
  marker = list(
    color = "red"
  ),
  line = list(
    color = "red",
    dash = "dashed"
  )
) %>%
  add_trace(
    x = ~date,
    y = ~fitted(loess(uempmed ~ as.numeric(date))),
    name = "fitted unemployment",
    mode = "markers+lines",
    marker = list(
      color = "orange"
    ),
    line = list(
      color = "orange"
    )
  ) %>%
  layout(
    title = "失业时间",
    xaxis = list(
      title = "日期",
      showgrid = F
    ),
    yaxis = list(
      title = "失业时间(周)"
    ),
    legend = list(
      x = 0, y = 1, orientation = "v",
      title = list(text = "")
    )
  )

图 12.13: 拟合曲线

12.14 轨迹图

rasterly 百万量级的散点图

library(rasterly)
plot_ly(quakes, x = ~long, y = ~lat) %>%
  add_rasterly_heatmap()

图 12.14: 散点图

quakes %>%
  rasterly(mapping = aes(x = long, y = lat)) %>%
  rasterly_points()
散点图

图 12.14: 散点图

library(plotly)
# 读取数据
# uber 轨迹数据来自 https://github.com/plotly/rasterly
ridesDf <- readRDS(file = 'data/uber.rds')

ridesDf %>%
  rasterly(mapping = aes(x = Lat, y = Lon)) %>%
  rasterly_points()
轨迹数据

图 12.15: 轨迹数据

12.15 三维图 (plotly)

plot_ly(z = ~volcano) %>%
  add_surface()

图 12.16: 三维图形

plot_ly(x = c(0, 0, 1), y = c(0, 1, 0), z = c(0, 0, 0)) %>%
  add_mesh()

图 12.16: 三维图形

# https://plot.ly/r/reference/#scatter3d
transform(mtcars, am = ifelse(am == 0, "Automatic", "Manual")) %>%
  plot_ly(x = ~wt, y = ~hp, z = ~qsec, 
          color = ~am, colors = c("#BF382A", "#0C4B8E")) %>%
  add_markers() %>%
  layout(scene = list(
    xaxis = list(title = "Weight"),
    yaxis = list(title = "Gross horsepower"),
    zaxis = list(title = "1/4 mile time")
  ))

图 12.16: 三维图形

12.16 甘特图

项目管理必备,如图所示,本项目拆分成7个任务,一共使用3种项目资源

# https://plotly.com/r/gantt/
# 项目拆解为一系列任务,每个任务的开始时间,持续时间和资源类型
df <- data.frame(
  task = paste("Task", 1:8),
  start = as.Date(c(
    "2016-01-01", "2016-02-20", "2016-01-01",
    "2016-04-10", "2016-06-09", "2016-04-10",
    "2016-09-07", "2016-11-26"
  )),
  duration = c(50, 25, 100, 60, 30, 150, 80, 10),
  resource = c("A", "B", "C", "C", "C", "A", "B", "B")
) %>%
  transform(end = start + duration) %>%
  transform(y = 1:nrow(.))

plot_ly(data = df) %>%
  add_segments(
    x = ~start, xend = ~end,
    y = ~y, yend = ~y,
    color = ~resource,
    mode = "lines",
    colors = "Greys", 
    line = list(width = 20),
    showlegend = F,
    hoverinfo = "text",
    text = ~ paste(
      " 任务: ", task, "<br>",
      "启动时间: ", start, "<br>",
      "周期: ", duration, "天<br>",
      "资源: ", resource
    )
  ) %>%
  layout(
    xaxis = list(
      showgrid = F,
      title = list(text = "")
    ),
    yaxis = list(
      showgrid = F,
      title = list(text = ""),
      tickmode = "array",
      tickvals = 1:nrow(df),
      ticktext = unique(df$task),
      domain = c(0, 0.9)
    ),
    annotations = list(
      list(
        xref = "paper", yref = "paper",
        x = 0.80, y = 0.1,
        text = paste0(
          "项目周期: ", sum(df$duration), " 天<br>",
          "资源类型: ", length(unique(df$resource)), " 个<br>"
        ),
        font = list(size = 12),
        ax = 0, ay = 0,
        align = "left"
      ),
      list(
        xref = "paper", yref = "paper",
        x = 0.1, y = 1,
        xanchor = "left",
        text = "项目资源管理",
        font = list(size = 20),
        ax = 0, ay = 0,
        align = "left",
        showarrow = FALSE
      )
    )
  )

图 12.17: 甘特图

12.17 帕雷托图

帕雷托图 20/80 法则

# 数据来自 https://github.com/plotly/datasets 
dat <- data.frame(
  complaint = c(
    "Small portions", "Overpriced",
    "Wait time", "Food is tasteless", "No atmosphere", "Not clean",
    "Too noisy", "Food is too salty", "Unfriendly staff", "Food not fresh"
  ),
  count = c( 621L, 789L, 109L, 65L, 45L, 30L, 27L, 15L, 12L, 9L)
)

dat <- dat[order(-dat$count), ] %>%
  transform(cumulative = round(100 * cumsum(count) / sum(count), digits = 2))

# complaint 按 count 降序排列
dat$complaint <- reorder(x = dat$complaint, X = dat$count, FUN = function(x) 1/(1 + x))

plot_ly(data = dat) %>%
  add_bars(
    x = ~complaint, y = ~count,
    showlegend = F, color = I("gray60")
  ) %>%
  add_lines(
    x = ~complaint, y = ~cumulative, yaxis = "y2",
    showlegend = F, color = I("gray40")
  ) %>%
  layout(
    yaxis2 = list(
      tickfont = list(color = "black"),
      overlaying = "y",
      side = "right",
      title = "累积百分比(%)",
      showgrid = F
    ),
    xaxis = list(title = "投诉类型", showgrid = F, showline = F),
    yaxis = list(title = "数量", showgrid = F, showline = F)
  )

图 12.18: 帕雷托图

reorder() 对 complaint 按照降序还是升序由 FUN 函数的单调性决定,单调增对应升序,单调减对应降序

12.18 时间线

library(vistime)

pres <- data.frame(
  Position = rep(c("President", "Vice"), each = 3),
  Name = c("Washington", rep(c("Adams", "Jefferson"), 2), "Burr"),
  start = c("1789-03-29", "1797-02-03", "1801-02-03"),
  end = c("1797-02-03", "1801-02-03", "1809-02-03"),
  color = c("#cbb69d", "#603913", "#c69c6e"),
  fontcolor = c("black", "white", "black")
)

vistime(pres, col.event = "Position", col.group = "Name")

图 12.19: 时间线图

12.19 漏斗图

dat <- data.frame(
  category = c("访问", "下载", "潜客", "报价", "下单"),
  value = c(39, 27.4, 20.6, 11, 2)
) %>% 
  transform(percent = value / cumsum(value))

plot_ly(data = dat) %>%
  add_trace(
    type = "funnel",
    y = ~category,
    x = ~value,
    color = ~category, 
    colors = "Set2", 
    text = ~ paste0(value, "<br>", sprintf("%.2f%%", 100*percent)) ,
    hoverinfo = "text",
    showlegend = FALSE
  ) %>%
  layout(yaxis = list(
    categoryarray = ~category,
    title = ""
  ))

图 12.20: 漏斗图

plotly::plot_ly(data = dat) %>%
  plotly::add_trace(
    type = "funnel",
    y = ~category,
    x = ~value,
    marker = list(color = RColorBrewer::brewer.pal(n = 5, name = "Set2")),
    textposition = "auto",
    textinfo = "value+percent previous",
    hoverinfo = "none"
  ) %>%
  plotly::layout(yaxis = list(categoryarray = ~category, title = ""))

图 12.21: 漏斗图

12.20 雷达图

plot_ly(
  type = "scatterpolar", mode = "markers", fill = "toself"
) %>%
  add_trace(
    r = c(39, 28, 8, 7, 28, 39), color = I("gray40"),
    theta = c("数学", "物理", "化学", "英语", "生物", "数学"),
    name = "学生 A"
  ) %>%
  add_trace(
    r = c(1.5, 10, 39, 31, 15, 1.5), color = I("gray80"),
    theta = c("数学", "物理", "化学", "英语", "生物", "数学"),
    name = "学生 B"
  ) %>%
  layout(
    polar = list(
      radialaxis = list(
        visible = T,
        range = c(0, 50)
      )
    )
  )

图 12.22: 雷达图

12.21 瀑布图

盈亏图

library(plotly)
library(dplyr)

dat <- data.frame(
  x = c(
    "销售", "咨询", "净收入",
    "购买", "其他费用", "税前利润"
  ),
  y = c(60, 80, 10, -40, -20, 0),
  measure = c(
    "relative", "relative", "relative",
    "relative", "relative", "total"
  )
) %>%
  mutate(text = case_when(
    y > 0 ~ paste0("+", y),
    y == 0 ~ "",
    y < 0 ~ as.character(y)
  )) %>%
  mutate(x = factor(x, levels = c(
    "销售", "咨询", "净收入",
    "购买", "其他费用", "税前利润"
  )))

n_rows <- nrow(dat)
dat[nrow(dat), "text"] <- "累计"

# measure 取值为 'relative'/'total'/'absolute'
plotly::plot_ly(dat,
  x = ~x, y = ~y, measure = ~measure, type = "waterfall",
  text = ~text, textposition = "outside", 
  name = "收支", hoverinfo = "final", 
  connector = list(line = list(color = "gray")),
  increasing = list(marker = list(color = "#66C2A5")),
  decreasing = list(marker = list(color = "#FC8D62")),
  totals = list(marker = list(color = "#8DA0CB"))
) %>%
  plotly::layout(
    title = "2018 年收支状态",
    xaxis = list(title = "业务"),
    yaxis = list(title = "金额"),
    showlegend = FALSE
  )

图 11.98: 瀑布图

12.22 树状图

plotly 绘制 treemap 和 sunburst 图比较复杂,接口不友好, plotme 正好弥补不足。

12.23 旭日图

plotme

12.24 调色板

plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width,
  mode = "markers", type = "scatter",
  color = ~ Sepal.Length > 6, colors = c("#132B43", "#56B1F7")
)
plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
  mode = "markers", type = "scatter"
)
plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
  mode = "markers", type = "scatter", colors = "Set2"
)
plot_ly(iris,
  x = ~Petal.Length, y = ~Petal.Width, color = ~ Sepal.Length > 6,
  mode = "markers", type = "scatter", colors = "Set1"
)

构造 20 个类别 超出 Set1 调色板的范围,会触发警告说 Set1 没有那么多色块,但还是返回足够多的色块,也可以使用 viridisplasmamagmainferno 调色板

dat <- data.frame(
  dt = rep(seq(
    from = as.Date("2021-01-01"),
    to = as.Date("2021-01-31"), by = "day"
  ), each = 20),
  bu = rep(LETTERS[1:20], 31),
  qv = rbinom(n = 20 * 31, size = 10000, prob = runif(20 * 31))
)
# viridis
plot_ly(dat,
  x = ~dt, y = ~qv, color = ~bu, 
  mode = "markers", type = "scatter", colors = "viridis"
)

图 12.23: 调色板

12.25 时序图

dygraphs 专门用来绘制交互式时间序列图形,下面以美团股价为例,展示时间窗口筛选、坐标轴名称、刻度标签、注释、事件标注、缩放等功能

meituan <- quantmod::getSymbols("3690.HK", auto.assign = FALSE, src = "yahoo")
library(dygraphs)
# 缩放
dyUnzoom <- function(dygraph) {
  dyPlugin(
    dygraph = dygraph,
    name = "Unzoom",
    path = system.file("plugins/unzoom.js", package = "dygraphs")
  )
}

# 年月
getYearMonth <- '
  function(d) {
    var monthNames = ["01", "02", "03", "04", "05", "06","07", "08", "09", "10", "11", "12"];
    date = new Date(d);
    return date.getFullYear() + "-" + monthNames[date.getMonth()]; 
  }'

dygraph(meituan[, "3690.HK.Adjusted"], main = "美团股价走势") |> 
  dyRangeSelector(dateWindow = c(format(Sys.Date(), "%Y-01-01"), as.character(Sys.Date())))  |> 
  dyAxis(name = "x", axisLabelFormatter = getYearMonth)  |> 
  dyAxis("y", valueRange = c(0, 500), label = "美团股价")  |> 
  dyEvent("2020-01-23", "武汉封城", labelLoc = "bottom")  |> 
  dyShading(from = "2020-01-23", to = "2020-04-08", color = "#FFE6E6")  |> 
  dyAnnotation("2020-01-23", text = "武汉封城", tooltip = "武汉封城", width = 60)  |> 
  dyAnnotation("2020-04-08", text = "武汉解封", tooltip = "武汉解封", width = 60)  |> 
  dyHighlight(highlightSeriesOpts = list(strokeWidth = 2))  |> 
  dySeries(label = "调整股价")  |> 
  dyLegend(show = "follow", hideOnMouseOut = FALSE)  |> 
  dyOptions(fillGraph = TRUE, drawGrid = FALSE, gridLineColor = "lightblue")  |> 
  dyUnzoom()

图 12.24: 美团股价走势

12.26 导出静态图形

orca (Open-source Report Creator App) 软件针对 plotly.js 库渲染的图形具有很强的导出功能,安装 orca 后,plotly::orca() 函数可以将基于 htmlwidgets 的 plotly 图形对象导出为 PNG、PDF 和 SVG 等格式的高质量静态图片。

p <- plot_ly(x = 1:10, y = 1:10, color = 1:10)
orca(p, "plot.svg")

12.27 静态图形转交互图形

函数 ggplotly() 将 ggplot 对象转化为交互式 plotly 对象

gg <- ggplot(faithful, aes(x = eruptions, y = waiting)) +
  stat_density_2d(aes(fill = ..level..), geom = "polygon") +
  xlim(1, 6) +
  ylim(40, 100)

静态图形

gg

转化为 plotly 对象

添加动态点的注释,比如点横纵坐标、坐标文本,整个注释标签的样式(如背景色)

ggplotly(gg, dynamicTicks = "y") %>%
  style(., hoveron = "points", hoverinfo = "x+y+text", 
        hoverlabel = list(bgcolor = "white"))

12.28 地图 II

leaflet 包制作地图,斐济是太平洋上的一个岛国,处于板块交界处,经常发生地震,如下图所示,展示 1964 年来 1000 次震级大于 4 级的地震活动。

library(leaflet)
data(quakes)
# Pop 提示
quakes$popup_text <- lapply(paste(
  "编号:", "<strong>", quakes$stations, "</strong>", "<br>",
  "震深:", quakes$depth, "<br>",
  "震级:", quakes$mag
), htmltools::HTML)
# 构造调色板
pal <- colorBin("Spectral", bins = pretty(quakes$mag), reverse = TRUE)
p <- leaflet(quakes) |>
  addProviderTiles(providers$CartoDB.Positron) |>
  addCircles(lng = ~long, lat = ~lat, color = ~ pal(mag), label = ~popup_text) |>
  addLegend("bottomright",
    pal = pal, values = ~mag,
    title = "地震震级"
  ) |>
  addScaleBar(position = c("bottomleft"))
p
斐济地震带

图 12.25: 斐济地震带

将上面的绘图部分保存为独立的 HTML 网页文件

library(htmlwidgets)
# p 就是绘图部分的数据对象
saveWidget(p, "fiji-map.html", selfcontained = T)
library(leaflet)
library(leaflet.extras)

quakes |>
  leaflet() |>
  addTiles() |>
  addProviderTiles(providers$OpenStreetMap.DE) |>
  addHeatmap(
    lng = ~long, lat = ~lat, intensity = ~mag,
    max = 100, radius = 20, blur = 10
  )
斐济地震带热力图

图 12.26: 斐济地震带热力图

leafletCN 提供汉化

# 地图默认放大倍数
zoom         <- 4
# 地图可以放大的倍数区间
minZoom      <- 1
maxZoom      <- 18

library(leaflet)
library(leafletCN)
library(maptools)
library(leaflet.extras)

# 热力图 heatmap
leaflet(res, options = leafletOptions(minZoom = minZoom, maxZoom = maxZoom)) |>
  amap() |>
  # setView(lng = mean(data$long), lat = mean(data$lat), zoom = zoom) |>
  setView(lng = 109, lat = 38, zoom = 4) |>
  addHeatmap(
    lng = ~long2, lat = ~lat2, intensity = ~uv, max = max(res$uv),
    blur = blur, minOpacity = minOpacity, radius = radius
  )

quakes$popup_text <- lapply(paste(
  "编号:", "<strong>", quakes$stations, "</strong>", "<br>",
  "震深:", quakes$depth, "<br>",
  "震级:", quakes$mag
), htmltools::HTML)
# 构造调色板
pal <- colorBin("Spectral", bins = pretty(quakes$mag), reverse = TRUE)

leaflet(quakes) |>
  addProviderTiles(providers$CartoDB.Positron) |>
  addCircles(
    lng = ~long, lat = ~lat,
    color = ~ pal(mag), label = ~popup_text
  ) |>
  setView(178, -20, 5) |>
  addHeatmap(
    lng = ~long, lat = ~lat, intensity = ~mag,
    blur = 20, max = 0.05, radius = 15
  ) |>
  addLegend("bottomright",
    pal = pal, values = ~mag,
    title = "地震震级"
  ) |>
  addScaleBar(position = c("bottomleft"))

12.29 动画

# https://d.cosx.org/d/422311
library(echarts4r)

data("gapminder", package = "gapminder")

titles <- lapply(unique(gapminder$year), function(x) {
  list(
    text = "Gapminder",
    left = "center"
  )
})

years <- lapply(unique(gapminder$year), function(x) {
  list(
    subtext = x,
    left = "center",
    top = "center",
    z = 0,
    subtextStyle = list(
      fontSize = 100,
      color = "rgb(170, 170, 170, 0.5)",
      fontWeight = "bolder"
    )
  )
})

# 添加一列颜色,各大洲和颜色的对应关系可自定义,调整 levels 或 labels 里面的顺序即可,也可不指定 levels ,调用其它调色板
gapminder <- within(gapminder, {
  color <- factor(
    continent,
    levels = c("Asia", "Africa", "Americas", "Europe", "Oceania"),
    labels = RColorBrewer::brewer.pal(n = 5, name = "Spectral")
  )
})

gapminder |>
  group_by(year) |>
  e_charts(x = gdpPercap, timeline = TRUE) |>
  e_scatter(
    serie = lifeExp, size = pop, bind = country,
    symbol_size = 5, name = ""
  ) |>
  e_add("itemStyle", color) |>
  e_y_axis(
    min = 20, max = 85, nameGap = 30,
    name = "Life Exp", nameLocation = "center"
  ) |>
  e_x_axis(
    type = "log", min = 100, max = 100000,
    nameGap = 30, name = "GDP / Cap", nameLocation = "center"
  ) |>
  e_timeline_serie(title = titles) |>
  e_timeline_serie(title = years, index = 2) |>
  e_timeline_opts(playInterval = 1000) |>
  e_grid(bottom = 100) |>
  e_tooltip()
# params.name 对应 bind
# params.value[0] 对应 x
# params.value[1] 对应 serie
# params.value[2] 对应 size
# tooltips 自定义
# https://stackoverflow.com/questions/50554304/displaying-extra-variables-in-tooltips-echarts4r
# 百分数处理
# https://stackoverflow.com/questions/11832914/how-to-round-to-at-most-2-decimal-places-if-necessary
mtcars |>
  tibble::rownames_to_column("model") |>
  e_charts(x = wt) |>
  e_scatter(serie = mpg, size = qsec, bind = model) |>
  e_tooltip(formatter = htmlwidgets::JS("
          function(params) {
              return (
                  '<strong>' + params.name + '</strong>' +
                  '<br />wt: ' + params.value[0] +
                  '<br />mpg: ' + params.value[1] +
                  '<br />qsec- ' + params.value[2]
              )
          }
          "))

12.30 三维图 (rgl)

ggrgl

library(rgl)
lat <- matrix(seq(90, -90, len = 50) * pi / 180, 50, 50, byrow = TRUE)
long <- matrix(seq(-180, 180, len = 50) * pi / 180, 50, 50)

r <- 6378.1 # radius of Earth in km
x <- r * cos(lat) * cos(long)
y <- r * cos(lat) * sin(long)
z <- r * sin(lat)
# 调整视角
rgl.viewpoint( theta = 0, phi = 15, fov = 60, zoom = 0.5, interactive = TRUE)

persp3d(x, y, z,
  col = "white", xlab = "", ylab = "", zlab = "",
  texture = system.file("textures/world.png", package = "rgl"),
  specular = "black", axes = FALSE, box = FALSE,
  normal_x = x, normal_y = y, normal_z = z
)

12.31 网络图

gephi 探索和可视化网络图 GraphViz

# library(igraph)

12.31.1 networkD3

networkD3 D3 非常适合绘制网络图,如网络、树状、桑基图

library(networkD3)
data(MisLinks, MisNodes) # 加载数据
head(MisLinks) # 边
##   source target value
## 1      1      0     1
## 2      2      0     8
## 3      3      0    10
## 4      3      2     6
## 5      4      0     1
## 6      5      0     1
head(MisNodes) # 节点
##              name group size
## 1          Myriel     1   15
## 2        Napoleon     1   20
## 3 Mlle.Baptistine     1   23
## 4    Mme.Magloire     1   30
## 5    CountessdeLo     1   11
## 6        Geborand     1    9

构造网络图

forceNetwork(
  Links = MisLinks, Nodes = MisNodes, Source = "source",
  Target = "target", Value = "value", NodeID = "name",
  Group = "group", opacity = 0.4
)

12.31.2 visNetwork

visNetwork 使用 vis-network.js 库绘制网络关系图 https://datastorm-open.github.io/visNetwork

调用函数 visTree() 可视化分类模型结果

library(rpart)
library(sparkline) # 函数 visTree 需要导入 sparkline 包
res <- rpart(Species~., data=iris)
visTree(res, main = "鸢尾花分类树", width = "100%")

节点、边的属性都可以映射数据指标

12.31.3 r2d3

D3 是非常流行的 JavaScript 库,r2d3 提供了 R 接口

更加具体的使用介绍,一个复杂的案例,如何从简单配置过来,以条形图为例, D3 是一个相当强大且成熟的库,提供的案例功能要覆盖 plotly

r2d3 提供了两个样例 JS 库 baranims.jsbarchart.js

list.files(system.file("examples/", package = "r2d3"))
## [1] "baranims.js" "barchart.js"
library(r2d3)
r2d3(
  data = c(0.3, 0.6, 0.8, 0.95, 0.40, 0.20),
  script = system.file("examples/barchart.js", package = "r2d3")
)

图 12.27: D3 图形

r2d3(
  data = c(0.3, 0.6, 0.8, 0.95, 0.40, 0.20),
  script = system.file("examples/baranims.js", package = "r2d3")
)

图 12.28: D3 图形

提供一个 R 包和 HTML Widgets 小练习:给 roughViz.js 写个 R 包装 https://d.cosx.org/d/421030-r-html-widgets-roughviz-js-r https://github.com/XiangyunHuang/roughviz

12.32 Python 交互图形

Plotly 的图形库

import plotly.express as px

px.scatter(
    px.data.iris(),
    x="sepal_width",
    y="sepal_length",
    color="species",
    trendline="ols",
    template="simple_white",
    labels={
        "sepal_length": "Sepal Length (cm)",
        "sepal_width": "Sepal Width (cm)",
        "species": "Species of Iris",
    },
    title="Edgar Anderson's Iris Data",
    color_discrete_sequence=px.colors.qualitative.Set2
)

不能同时使用 Python 版和 R 版的 Plotly.js 库,因为版本不一致产生冲突,而不能显示图形。

12.33 运行环境

## R version 4.2.0 (2022-04-22)
## Platform: x86_64-pc-linux-gnu (64-bit)
## Running under: Ubuntu 20.04.4 LTS
## 
## Matrix products: default
## BLAS:   /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0
## LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
## 
## locale:
##  [1] LC_CTYPE=en_US.UTF-8       LC_NUMERIC=C              
##  [3] LC_TIME=en_US.UTF-8        LC_COLLATE=en_US.UTF-8    
##  [5] LC_MONETARY=en_US.UTF-8    LC_MESSAGES=en_US.UTF-8   
##  [7] LC_PAPER=en_US.UTF-8       LC_NAME=C                 
##  [9] LC_ADDRESS=C               LC_TELEPHONE=C            
## [11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C       
## 
## attached base packages:
## [1] stats     graphics  grDevices utils     datasets  methods   base     
## 
## other attached packages:
##  [1] sparkline_2.0     rpart_4.1.16      visNetwork_2.1.0  networkD3_0.4    
##  [5] echarts4r_0.4.3   dplyr_1.0.9       vistime_1.2.1     rasterly_0.2.0   
##  [9] Rcpp_1.0.8.3      data.table_1.14.2 r2d3_0.2.6        dygraphs_1.1.1.6 
## [13] plotly_4.10.0     ggplot2_3.3.6     reticulate_1.25  
## 
## loaded via a namespace (and not attached):
##  [1] fs_1.5.2                   xts_0.12.1                
##  [3] RColorBrewer_1.1-3         httr_1.4.3                
##  [5] tools_4.2.0                bslib_0.3.1               
##  [7] utf8_1.2.2                 R6_2.5.1                  
##  [9] DBI_1.1.2                  lazyeval_0.2.2            
## [11] colorspace_2.0-3           withr_2.5.0               
## [13] tidyselect_1.1.2           downlit_0.4.0             
## [15] curl_4.3.2                 compiler_4.2.0            
## [17] cli_3.3.0                  assertive.properties_0.0-5
## [19] xml2_1.3.3                 isoband_0.2.5             
## [21] labeling_0.4.2             bookdown_0.26             
## [23] sass_0.4.1                 scales_1.2.0              
## [25] stringr_1.4.0              digest_0.6.29             
## [27] rmarkdown_2.14             pkgconfig_2.0.3           
## [29] htmltools_0.5.2            fastmap_1.1.0             
## [31] highr_0.9                  htmlwidgets_1.5.4         
## [33] rlang_1.0.2                TTR_0.24.3                
## [35] rstudioapi_0.13            quantmod_0.4.20           
## [37] sysfonts_0.8.8             shiny_1.7.1               
## [39] jquerylib_0.1.4            farver_2.1.0              
## [41] generics_0.1.2             zoo_1.8-10                
## [43] jsonlite_1.8.0             crosstalk_1.2.0           
## [45] magrittr_2.0.3             Matrix_1.4-1              
## [47] munsell_0.5.0              fansi_1.0.3               
## [49] lifecycle_1.0.1            stringi_1.7.6             
## [51] assertive.base_0.0-9       yaml_2.3.5                
## [53] MASS_7.3-57                grid_4.2.0                
## [55] promises_1.2.0.1           ggrepel_0.9.1             
## [57] crayon_1.5.1               lattice_0.20-45           
## [59] knitr_1.39                 pillar_1.7.0              
## [61] igraph_1.3.1               codetools_0.2-18          
## [63] glue_1.6.2                 evaluate_0.15             
## [65] png_0.1-7                  vctrs_0.4.1               
## [67] httpuv_1.6.5               gtable_0.3.0              
## [69] purrr_0.3.4                tidyr_1.2.0               
## [71] assertthat_0.2.1           cachem_1.0.6              
## [73] xfun_0.31                  mime_0.12                 
## [75] xtable_1.8-4               assertive.types_0.0-3     
## [77] later_1.3.0                viridisLite_0.4.0         
## [79] tibble_3.1.7               memoise_2.0.1             
## [81] ellipsis_0.3.2